home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / front_end / safe.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  5.8 KB  |  169 lines
  1. (herald safe)
  2.  
  3. ;;; A procedure is type-safe if type checking is done for all primop calls
  4. ;;; it contains.  This code is used to produce closed compiled versions of
  5. ;;; primops.  It is not guarenteed to produce code that is 100% type-safe.
  6.  
  7. ;;; Turn NODE into a type-safe procedure.
  8.  
  9. (define (make-type-safe node)
  10.   (cond ((lambda-node? node)
  11.          (real-make-type-safe node '())
  12.          (simplify-call node))
  13.         ((object-node? node)
  14.          (real-make-type-safe node '()))
  15.         (else
  16.          (bug '"MAKE-TYPE-SAFE called on ~S" node))))
  17.  
  18. ;;; TYPES is a list of (<variable> . <type>) pairs indicating that <variable>
  19. ;;; is known to have type <type>.  This is used to prevent unnecessary type
  20. ;;; tests.
  21.  
  22. (define (real-make-type-safe node types)
  23.   (cond ((lambda-node? node)
  24.          (make-call-type-safe (lambda-body node) types))
  25.         ((object-node? node)
  26.          (real-make-type-safe (object-proc node) types)
  27.          (walk (lambda (m)
  28.                  (real-make-type-safe m types))
  29.                (object-methods node)))
  30.         (else nil)))
  31.  
  32. ;;; Make a call type-safe.
  33.  
  34. (define (make-call-type-safe call types)
  35.   (cond ((primop-node? (call-proc call))
  36.          (make-primop-type-safe call (primop-value (call-proc call)) types))
  37.         (else
  38.          (walk (lambda (n)
  39.                  (real-make-type-safe n types))
  40.                (call-proc+args call)))))
  41.  
  42. ;;; Make a call to a primop type-safe.  This gets the necessary tests and
  43. ;;; corresponding known variable types and then makes the arguments type-safe
  44. ;;; and inserts the tests.
  45.  
  46. (define (make-primop-type-safe call primop types)
  47.   (receive (tests types)
  48.            (get-primop-arg-typing (primop.type primop call)
  49.                                   (call-args call)
  50.                                   types)
  51.     (walk (lambda (n)
  52.             (real-make-type-safe n types))
  53.           (call-args call))
  54.     (walk (lambda (p)
  55.             (insert-test (node-parent call) (car p) (cdr p)))
  56.           tests)))
  57.  
  58. ;;; TYPE is the type of the primop, ARGS are the actual arguments, and TYPES
  59. ;;; are the known variable types.  Each argument is checked to see if it
  60. ;;; requires testing.
  61.  
  62. (define (get-primop-arg-typing type args types)
  63.   (cond ((not (proc-type? type))
  64.          (return '() types))
  65.         (else
  66.          (let ((arg-types (proc-type-args type)))
  67.            (iterate loop ((args args) (i 1) (tests '()) (types types))
  68.              (if (null? args)
  69.                  (return tests types)
  70.                  (receive (ntest ntype)
  71.                           (new-typing (car args) (vref arg-types i) types)
  72.                    (loop (cdr args) (fx+ i 1)
  73.                          (append ntest tests)
  74.                          (append ntest ntype types)))))))))
  75.  
  76. ;;; Dispatch on TYPE and the node type of ARG.
  77.  
  78. (define (new-typing arg type types)
  79.   (cond ((type-top? type)
  80.          (return '() '()))
  81.         ((and (lambda-node? arg)
  82.               (proc-type? type))
  83.          (return '() (add-procedure-types type arg)))
  84.         ((and (reference-node? arg)
  85.               (not (proc-type? type)))
  86.          (return (new-variable-typing (reference-variable arg) type types)
  87.                  '()))
  88.         (else
  89.          (return '() '()))))
  90.  
  91. ;;; Returns the known types of ARG's variables given that it is called by
  92. ;;; by a primop expecting something of type TYPE.
  93.  
  94. (define (add-procedure-types type arg)
  95.   (let ((arg-types (proc-type-args type)))
  96.     (iterate loop ((vars (lambda-variables arg)) (i 1) (types '()))
  97.       (cond ((null? vars)
  98.              types)
  99.             ((or (not (used? (car vars)))
  100.                  (or (type-top? (vref arg-types i))
  101.                      (proc-type? (vref arg-types i))))
  102.              (loop (cdr vars) (fx+ i 1) types))
  103.             (else
  104.              (loop (cdr vars) (fx+ i 1)
  105.                    `((,(car vars) . ,(vref arg-types i)) . ,types)))))))
  106.  
  107. ;;; Produce any additional type test needed to guarentee that VAR is of type
  108. ;;; TYPE.
  109.  
  110. (define (new-variable-typing var type types)
  111.   (let ((known (assq var types)))
  112.     (cond ((and known
  113.                 (type-subset? type (cdr known)))
  114.            '())
  115.           (else
  116.            (let ((type (if (not known)
  117.                            type
  118.                            (type-subtract type (cdr known)))))
  119.              `((,var . ,type)))))))
  120.  
  121. ;;; Insert a test to guarentee that VAR is of type TYPE in the body of L-NODE.
  122. ;;;
  123. ;;; (LAMBDA <vars> <body>) + <var> + <type>
  124. ;;;   =>
  125. ;;; (LAMBDA <vars>
  126. ;;;   (LET ((W (IF (<type-test> <var>)
  127. ;;;                <var>
  128. ;;;                (*ENFORCE <type-test> <var>))))
  129. ;;;     <body>[W/<var>]))
  130.  
  131. (define (insert-test l-node var type)
  132.   (let ((old-body (detach (lambda-body l-node)))
  133.         (test (type->system-variable type))
  134.         (*enforce (get-free-variable '*enforce))) ; Not the right thing
  135.     (let-nodes ((call ((* test) 1 cont (* var)))
  136.                   (cont (#f v) ((^ cond) 1 (^ join)))
  137.                     (cond (#f j) (($ primop/conditional)
  138.                                   2
  139.                                   yes
  140.                                   no
  141.                                   ($ primop/test)
  142.                                   ($ primop/true?)
  143.                                   (* v)))
  144.                       (yes () ((* j) 0 (* var)))
  145.                       (no () ((* *enforce) 1 (* j) (* test) (* var)))
  146.                     (join (#f w) old-body))
  147.       (substitute-vars-in-node-tree old-body (list var) (list w))
  148.       (relate lambda-body l-node call)
  149.       (mark-all-changed (call-proc call)))))
  150.  
  151. ;;; Get the name of the system predicate that tests for TYPE.
  152.  
  153. (define (type->system-variable type)
  154.   (let ((pred (type-predicate type)))
  155.     (if pred
  156.         (get-system-variable pred)
  157.         (bug '"no predicate for type ~S" (type-name type)))))
  158.  
  159. ;;; Mark all ancestors of NODE as having been modified.
  160.  
  161. (define (mark-all-changed node)
  162.   (do ((p (node-parent node) (node-parent p)))
  163.       ((not (node? p)))
  164.     (set (node-simplified? p) nil)))
  165.  
  166.  
  167.  
  168.  
  169.